perm filename INTERP.PAL[HAL,HE]14 blob
sn#185820 filedate 1975-11-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00025 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 .SBTTL Interpreter Data structures, INTINIT
C00009 00003 Interpreter itself: INTERP
C00015 00004 GETARG, GETSCA, GETVEC, GETTRN
C00019 00005 Variable declaration: MVAR, KVAR
C00022 00006 Stack ops: GTVAL, IGTVAL, CHNGE, ICHNGE, PUSH, POP, COPY, REPLACE, FLUSH
C00027 00007 Global reference routines GLBLNK, GLOBSR.
C00032 00008 Flow-of-control: PROC, RETURN
C00038 00009 FORCHK, JUMP, JUMPC
C00041 00010 SPAWN, SPROUT, TERMINATE
C00049 00011 Graph node handlers: MCLC, ENDCLC
C00054 00012 MCHGR, GTOLD, GTNEW
C00057 00013 return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG, SSBRTN
C00064 00014 Vector utilities: UNITV, CROSV
C00070 00015 Return vectors: SVMUL, TVMUL, VMAKE, VADD
C00074 00016 Return a trans: TMAKE, TVADD, TTMUL
C00079 00017 Motion: MOVE
C00081 00018 Condition monitors: CMMAK
C00087 00019 CMENBL, CMDSBL, CMDEST, CMTRIG, CMSKED, CMUNCR
C00094 00020 Force condition monitors. Data structures. TABOFS, FMBLK, MAKFORCE, DESFORCE
C00102 00021 GETFORCE, MAKRT
C00109 00022 Events: MAKEVT, SIGNAL, WAITE, DESEVT
C00114 00023 Debugging aids: PRINT, PRNTS
C00118 00024 BREAK, NOOP, TOPAL, IOINIT
C00120 00025 BUGS
C00121 ENDMK
C⊗;
.SBTTL Interpreter ;Data structures, INTINIT
COMMENT ⊗
Register uses in the interpreter:
R5 used by some routines as the display register
R4 points to interpreter status block
R3 interpreter stack pointer
R2 not used by the main interpreter loop. Can be munged by
any primary interpreter routine.
Each interpreter has a stack which it uses to store pointers to
currently "open" variables. During the course of a calculation,
operands and temporary result cells will be open in this fashion.
The "interpreter stack" is pointed to by R3. When a new interpreter
is sprouted, it is given a new stack area. Each interpreter has
certain status information which facilitates transfer of control
between interpreters. This information is kept in the interpreter
status block, which is always pointed to by R4. Most important are
the IPC, the Interpreter Program Counter, the ENV, which points to
the local environment, and LEV, which stores the current lexical
level.
Each procedure has an environment, which is a data area holding
information vital to that procedure. This includes pointers to all
the variables local to that procedure, and return information. ⊗
INSTSZ == 20 ;Size of an interpreter stack
;Interpreter status block
II == 0
XX IPC ;Interpreter program counter. Leave this as first field!
XX NXTINT ;Next interpreter in the list. For GC of the stacks.
XX STKBAS ;Location of start of stack area. Needed
;for eventual reclamation.
XX ENV ;Location of local environment
XX LEV ;Lexical level of current execution
XX STA ;Status bits for condition codes: 0 means all well.
XX PCB ;Location of process control block (for reclamation)
XX EVT ;The event to signal as this interpreter goes away
XX CMCB ;Pointer to c-m control block if this is a checker or a body
XX OLDV ;The "old value" used by changers
XX NEWV ;The "new value" used by changers
.IFNZ ALAID ;Special debugging information
XX DEBMOD ;The mode bits for debugging.
ALDSS == 1 ;1 => Single step mode
.ENDC
ISBS == II/2 ;Size (in words) of interpreter status block
;Fixed fields in the environment of each process
II == 0
XX SLINK ;Pointer to environment of next (outer, lower
; numbered) block
XX OLEV ;Old level. The lexical level of calling process.
XX OENV ;Old environment, the one for the calling process.
XX OIPC ;Old IPC. Program counter for calling process.
XX LVARS ;First location where pointers to local variables go
INTEVT: 0 ;The event that interlocks references to ISTBLK.
GLBEVT: 0 ;The event that interlocks references to GLBTAB.
INTINIT: ;Initializes the above events
EVMAK ;Initialize the INTEVT.
MOV (SP),INTEVT;
EVSIG ;
EVMAK ;Initialize the GLBEVT.
MOV (SP),GLBEVT ;
EVSIG ;
MOV #GLBTAB,GLBEND ;Initialize GLBEND. This wipes out all globals.
RTS PC ;Done
;Interpreter itself: INTERP
.MACRO MAKEOP CNAME, ANAME ;Compiler name, Address name
XX CNAME
ANAME
.ENDM
;The interpreter operation table
INTOPS: MAKEOP XINVALID,INVALID ;Illegal instruction
.INSRT INTOPS.PAL[HAL,HE]
INSEND = II ;Marks the end of the instructions
.MACRO BMPIPC ;
ADD #2,IPC(R4) ;Bump IPC
.ENDM ;
.MACRO CCC ;Clear condition code
; CLR R0 ;Clear condition code. Not used right now.
.ENDM
.MACRO SCC ;Set condition code
; MOV #2,R0 ;Set condition code. Not used right now.
.ENDM
.IFZ ALAID ;The ALAID version is in ALAID.PAL
INTERP:
MOV R3,R0 ;Save the limit of the interpreter stack for error checking.
SUB #INSTSZ-2,R0
MOV R0,-(SP) ;
INT1: CMP R3,(SP) ;Interpreter stack overflow?
BGE INT3 ;No. Go to next instruction.
HALERR INTMS3 ;Yes. Complain.
INT3: MOV @IPC(R4),R0 ;R0 ← next instruction
BLE INVALID ;Instruction out of range
CMP R0,#INSEND ;Is instruction too large?
BLE INT2 ;No.
INVALID:HALERR INTMS1 ;Yes. complain.
INT2: BMPIPC ;Bump IPC
JSR PC,@INTOPS(R0) ;Call the appropriate routine
BR INT1 ;Repeat interpreter loop
INTMS1: ASCIE /INTERPRETER INSTRUCTION OUT OF RANGE/
INTMS2: ASCIE /INTERPRETED INSTRUCTION RETURNED FAILURE/
INTMS3: ASCIE /INTERPRETER STACK OVERFLOW/
.ENDC
; GETARG, GETSCA, GETVEC, GETTRN
GETARG:
COMMENT ⊗
Arguments:
R0=variable name: high byte is lexical level, low byte is offset.
R4=pointer to interpreter status block.
Result:
R0← pointer to address of desired variable.
R1 clobbered.
This routine returns in R0 a pointer to the location in the current
environment (or, if necessary, more global environment) which
points to the variable which is named in R0. ⊗
MOV R2,-(SP) ;Save R2
MOVB R0,R1 ;R1 ← Offset desired
CLRB R0 ;
SWAB R0 ;R0 ← Lexical level
MOV ENV(R4),R2 ;R2 ← LOC[local environment]
SUB LEV(R4),R0 ;R0 ← Difference in levels: desired-got
BEQ GTRG1 ;Diff=0; can use R2 as pointer at right base.
BHI GTERR ;If diff>0, then value inaccessible.
GTRG2: MOV SLINK(R2),R2;Must go up a level. R2 ← LOC[more global environment]
INC R0 ;R0 ← New difference in levels
BNE GTRG2 ;If not yet good, then move up another level
GTRG1: ADD R2,R1 ;R1 ← environment + offset = location of desired pointer
MOV (SP)+,R2 ;Restore R2.
MOV R1,R0 ;
RTS PC ;Done.
GTERR: HALERR GTMS1
GTMS1: ASCIE /ATTEMPT TO ACCESS UNAVAILABLE VARIABLE/
GETSCA: ;Gets place for a scalar result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #SCASPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #2,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETVEC: ;Gets place for a vector result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #VCTSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #10,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETTRN: ;Gets place for a trans result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #TRNSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #40,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
;Variable declaration: MVAR, KVAR;
MVAR:
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, a fresh graph node
is created (with no value) and a pointer to it is placed in the
environment at the desired offset, current level. ⊗
MOV @IPC(R4),-(SP) ;push offset
BEQ MVAR1 ;If none, done
BMPIPC ;Bump IPC
CLR R0 ;The new graph node should get no value cell.
.IFZ GRAPH1
JSR PC,MAKEGN ;R0 ← LOC[a new graph node]
.IFF
JSR PC,MAKEVN ;R0 ← LOC[a new variable node]
.ENDC
ADD ENV(R4),(SP);stack pointer into environment
MOV R0,@(SP)+ ;Point the environment to the graph node
BR MVAR ;Repeat
MVAR1: TST (SP)+ ;Clean off stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
KVAR:
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, the corresponding
graph node is destroyed in the current environment. Any function in
the graph structure is thereby released. (Attempt is made to
validate any dependents first.) ⊗
MOV @IPC(R4),R2 ;R2 ← offset
BEQ KVAR1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R2 ;R2 ← LOC[pointer at graph node]
MOV (R2),R0 ;R0 ← LOC[graph node]
.IFZ GRAPH1
JSR PC,DELGN ;Get this guy deleted
.IFF
JSR PC,DELVN ;Get this guy deleted
.ENDC
CLR (R2) ;Remove the pointer in the environment
BR KVAR ;Repeat
KVAR1: BMPIPC ;Bump IPC
CCC ;Clear condition code
RTS PC ;Done
;Stack ops: GTVAL, IGTVAL, CHNGE, ICHNGE, PUSH, POP, COPY, REPLACE, FLUSH
GTVAL:
COMMENT ⊗ The argument is a level-offset pair. The variable
referenced by that pair is examined and a pointer to its value cell
is placed on the stack. ⊗
MOV @IPC(R4),R0 ;Pick up level-offset name of argument
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[desired graph node]]
MOV (R0),R0 ;R0 ← LOC[desired graph node]
BEQ GTVL2 ;But if 0, then bug
GTVL4: CALL GETVAL,<R0>;R0 ← value
GTVL3: MOV R0,-(R3) ;Push value on interpreter stack.
BEQ GTVL1 ;But if 0, then bug
CCC ;Clear condition code.
RTS PC ;Done
GTVL1: HALERR GTVMS1 ;Complain
SCC ;Set condition code
RTS PC ;Done
GTVL2: HALERR GTVMS2 ;Complain
BR GTVL3 ;But comply
GTVMS1: ASCIE </GTVAL FOUND A NULL VALUE. MAY CONTINUE/>
GTVMS2: ASCIE </GTVAL FOUND A NULL GRAPH NODE. MAY CONTINUE/>
IGTVAL:
COMMENT ⊗ Immediate version of GTVAL. The argument points directly
to the graph node whose value is desired. A pointer to the value
cell is placed on the stack. ⊗
MOV @IPC(R4),R0 ;R0 ← LOC[desired graph node]
BMPIPC ;Bump IPC
CALL GETVAL,<R0>;R0 ← value
MOV R0,-(R3) ;Push value on interpreter stack.
CCC ;Clear condition code.
RTS PC ;Done
CHNGE:
COMMENT ⊗ Pops the value from top of stack into the graph structure
pointed to by the level-offset pair given in the argument. ⊗
MOV @IPC(R4),R0 ;Pick up level-offset name of argument
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[Desired graph node]]
MOV (R0),R0 ;R0 ← LOC[Desired graph node]
BEQ CHNGE1 ;If any
CHNGE2: CALL CHANGE,<R0,(R3)>
POP: TST (R3)+ ;Pop stack
CCC ;Clear condition code.
RTS PC ;Done
CHNGE1: HALERR CHNMES ;Complain
TST (R3)+ ;Get rid of the value
SCC ;Set condition code
RTS PC ;Done
CHNMES: ASCIE </CAN'T ASSIGN INTO UNINITIALIZED VARIABLE/>
ICHNGE:
COMMENT ⊗ Immediate version of CHNGE. Pops the value from top of
stack into the graph structure pointed to directly by the argument. ⊗
MOV @IPC(R4),R0 ;R0 ← LOC[desired graph node]
BMPIPC ;Bump IPC
CALL CHANGE,<R0,(R3)>
TST (R3)+ ;Pop stack
CCC ;Clear condition code.
RTS PC ;Done
PUSH: MOV @IPC(R4),-(R3);Put argument directly on stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
; Interpreter routine. Copies the nth element in stack to the top,
; where the curent top is 0.
COPY: MOV @IPC(R4),R0 ;Pick up argument.
BMPIPC ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied to top]
MOV (R0),-(R3) ;Copy it onto top of stack.
CCC ;Clear condition code.
RTS PC ;Done
REPLAC: MOV @IPC(R4),R0 ;Pick up argument.
BMPIPC ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied into]
MOV (R3)+,(R0) ;Copy verge of stack into it.
CCC ;Clear condition code.
RTS PC ;Done
FLUSH: MOV STKBAS(R4),R3;Reset the stack base.
CCC ;Clear condition code.
RTS PC ;Done
;Global reference routines GLBLNK, GLOBSR.
GLBLNK: ;Interpreter routine
COMMENT ⊗ Expects two arguments at the IPC, a level-offset, and two
words of a Rad50 name. Makes sure that this global is linked in to
the environment at the given level-offset. If not, a search is
made for it, and the result is put in the environment.
⊗
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC past the level-offset
JSR PC,GETARG ;R0 ← LOC[environment cell]
TST (R0) ;Graph node yet?
BEQ GLOBG1 ;No, must search for it
GLOBG2: BMPIPC ;Bump IPC past the Rad50 name
BMPIPC ;Bump IPC past the Rad50 name
RTS PC ;Done
GLOBG1: MOV R0,R2 ;R2 ← LOC[environment cell]
MOV IPC(R4),R0 ;R0 ← LOC[Rad50 representation]
JSR PC,GLOBSR ;R0 ← LOC[new or old graph node]
MOV R0,(R2) ;Stow LOC[graph node] in the environment cell
BR GLOBG2 ;Ready to return
MAXGLB == 10 ;Maximum number of globals allowed
GLBTAB: .BLKW 3*MAXGLB ;Three words per global: 2 of Rad50, one
;pointer to the graph node.
;To be searched linearly.
GLBLIM: .BLKW 3 ;Overflow place for GLBTAB
GLBEND: .BLKW 1 ;Points to next free place in GLBTAB
GLOBSR:
COMMENT ⊗ R0 = LOC[two words of Rad50]. Tries to find the
appropriate graph node using the GLBTAB, and if it fails, makes a new
graph node and inserts it in the GLBTAB. In any case, returns R0 ←
LOC[new or old graph node]. ⊗
EVWAIT GLBEVT ;Critical region starts here
MOV GLBEND,R1 ;R1 ← LOC[next free place in GLBTAB]
MOV (R0),(R1)+ ;Put the word sought at next free place
MOV 2(R0),(R1)+ ;
CLR (R1) ; with a 0 for a graph node pointer.
MOV #GLBTAB,R1 ;R1 ← LOC[start of GLBTAB]
GLOBS3: CMP (R0),(R1) ;MATCH?
BNE GLOBS1 ;No.
CMP 2(R0),2(R1) ;Second word match?
BEQ GLOBS2 ;Yes.
GLOBS1: ADD #6,R1 ;
BR GLOBS3 ;Try again.
GLOBS2: MOV 4(R1),R0 ;R0 ← LOC[graph node]
BNE GLOBS6 ;If it is not zero, we are done
ADD #6,GLBEND ;Move the end of the table down one entry
CMP GLBEND,#GLBLIM ;Too far?
BLT GLOBS5 ;No
HALERR GLOBMS ;Yes
GLOBS5: MOV R1,-(SP) ;Save place in GLBTAB
CLR R0 ;New graph node should have no value cell.
.IFZ GRAPH1
JSR PC,MAKEGN ;R0 ← LOC[a new graph node]
.IFF
JSR PC,MAKEVN ;R0 ← LOC[a new variable node]
.ENDC
MOV (SP)+,R1 ;Restore place in GLBTAB
MOV R0,4(R1) ;store LOC[new graph node] in GLBTAB
GLOBS6: EVSIG GLBEVT ;Critical region ends here
RTS PC ;Done
GLOBMS: ASCIE </TOO MANY GLOBALS/>
;Flow-of-control: PROC, RETURN
PROC:
;Procedure call. Arguments:
; Destination.
; List of variables which are to be inserted in appropriate
; locations in the local storage of procedure. These are
; in the format variable (ie level-offset pair), new offset
; (right justified in the second word).
; There is a zero word to finish these.
;At the destination address can be found:
II == 0
XX FSLGTH ;Number of words to get from free storage
;for local variable pointers
XX PLEV ;Lexical level of procedure
DSLGTH == II ;Number of words before code starts
;Value parameters should have first been copied first into local temps
; (which have been arranged by the compiler), and then the temps are
; passed by reference. Eventual problem: to know which variables to
; really kill as the procedure is exited.
MOV @IPC(R4),R2 ;R2 ← LOC[destination]
BMPIPC ;Bump IPC
MOV FSLGTH(R2),R0 ;R0 ← Number of words to get.
JSR PC,GTFREE ;R0 ← LOC[block with that number of words]
;initialize pointer to lexical level:
MOV PLEV(R2),R1 ;R1 ← Lexical level of procedure
MOV ENV(R4),R2 ;R2 ← LOC[current environment]
SUB LEV(R4),R1 ;R1 ← Difference in levels: desired-got
BEQ PRC1 ;Diff=0; can use R2 as pointer at right environment.
PRC2: MOV SLINK(R2),R2;No, must go up a level. R2 ← LOC[base of upper area]
INC R1 ;R1 ← New difference in levels
BNE PRC2 ;If not yet good, then move up another level
PRC1: MOV R2,SLINK(R0);SLINK[new environment] ← correct global environment
;Put copies of local variables in new area
MOV R0,-(SP) ;Stack LOC[new environment]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BEQ PRC3 ;If there are no more, go to next phase
PRC4: BMPIPC ;Else bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[graph node]]
MOV @IPC(R4),R1 ;R1 ← offset in new block
BMPIPC ;Bump IPC
ADD (SP),R1 ;R1 ← LOC[place in new environment to put pointer]
MOV (R0),(R1) ;new environment gets pointer to LOC[argument graph node]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BNE PRC4 ;If there are more, go back and treat them
PRC3: BMPIPC ;Bump IPC one last time
;Save the old context in the new area
MOV (SP)+,R1 ;R1 ← LOC[new environment]
MOV LEV(R4),OLEV(R1) ;Store the old level
MOV ENV(R4),OENV(R1) ;Store the old environment location
MOV IPC(R4),OIPC(R1) ;Store the return address
;Set up the new context for procedure
MOV PLEV(R2),LEV(R4) ;New lexical level
MOV R1,ENV(R4) ;New environment location
ADD #DSLGTH,R2 ;R2 ← Place where execution should begin
MOV R2,IPC(R4) ;New program counter
CCC ;Clear condition code.
RTS PC ;Done
RETURN:
;Returns from a procedure call to calling program. Since variables are
;passed by reference, it is not necessary to do any copying of values.
;All that is needed is to restore the context of the caller and to
;discard the display.
MOV ENV(R4),R0 ;R0 ← LOC[current environment]
MOV OLEV(R0),LEV(R4) ;Restore the old lexical level
MOV OENV(R0),ENV(R4) ;Restore the old environment
MOV OIPC(R0),IPC(R4) ;Restore the IPC
JSR PC,RLFREE ;Release storage of old display
CCC ;Clear condition code.
RTS PC ;Done
; FORCHK, JUMP, JUMPC
FORCHK:
;Assume that the stack has, from surface in, the increment, the
; final value, and the control variable's value, all of which are
; scalar values. If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
; no-op; otherwise, jump to the destination.
;Arguments: destination.
LDF @2(R3),AC0 ;AC0 ← final value
SUBF @4(R3),AC0 ;AC0 ← final - current
MULF @(R3),AC0 ;AC0 ← (final - current)*increment
MOV @IPC(R4),R0 ;R0 ← destination
BMPIPC ;Bump IPC
CFCC ;
BGE FOR1 ;Shall this be a no-op?
MOV R0,IPC(R4) ;No; set new IPC.
FOR1: CLR R0 ;
RTS PC ;Done
JUMP:
;Takes one argument: the new address.
MOV @IPC(R4),IPC(R4)
CCC ;Clear condition code.
RTS PC ;Done
JUMPC: ;Interpreter routine
COMMENT ⊗ Two arguments: the condition and the destination address.
The condition queries the top of the stack and pops it, assuming it
to be a scalar. The interpreter jumps to the destination address if
the condition is satisfied. The possible conditions are 0(Never),
1(L), 2(E), 3(LE), 4(Always), 5(GE), 6(NE), 7(G). Note that
comparisons of equality must be exact to floating precision. ⊗
MOV @IPC(R4),R2 ;R2 ← condition
BMPIPC ;Bump IPC
BLT JMPCERR ;If out of range, complain.
MOV R2,R0 ;
SUB #7,R0 ;
BGT JMPCERR ;
MOV (R3)+,R0 ;R0 ← LOC[arg]
LDF (R0),AC0 ;AC0 ← arg
ADD R2,R2 ;
ADD R2,R2 ;Multiply condition by 4.
CFCC ;
JMP JMPC3(R2) ;Go to the right test.
JMPC3: BR JMPC1 ;N always fail
BR JMPC4 ;
BGE JMPC1 ;L
BR JMPC4 ;
BNE JMPC1 ;E
BR JMPC4 ;
BGT JMPC1 ;LE
BR JMPC4 ;
TST R0 ;A never fail
BR JMPC4 ;
BLT JMPC1 ;GE
BR JMPC4 ;
BEQ JMPC1 ;NE
BR JMPC4 ;
BLE JMPC1 ;G
JMPC4: MOV @IPC(R4),IPC(R4) ;Succeed
BR JMPC2 ;
JMPC1: BMPIPC ;Fail. Bump IPC
JMPC2: CCC ;Clear condition code.
RTS PC ;Done
JMPCER: HALERR JMPCMS ;
JMPCMS: ASCIE </ILLEGAL JUMPC CODE/>
; SPAWN, SPROUT, TERMINATE
SPAWN: ;Utility routine
COMMENT ⊗ Takes two arguments: In R0, the IPC of the interpreter to
spawn, and in R1, the event (if any) to put in EVT of the new
interpreter. The inferior will have the same environment as the
superior. Creates an interpreter status block, stack, process
descriptor, and is ready for a SCHEDU when it returns the process
descriptor in R0. ⊗
MOV R1,-(SP) ;Save the EVT
MOV R0,-(SP) ;Save the new IPC
MOV #ISBS,R0 ;R0 ← Size (in words) of an interpreter status block
JSR PC,GTFREE ;R0 ← LOC[new interpreter status block]
MOV (SP)+,IPC(R0);new IPC ← first argument
MOV ENV(R4),ENV(R0) ;new ENV ← old ENV
MOV LEV(R4),LEV(R0) ;new LEV ← old LEV
.IFNZ ALAID
MOV DEBMOD(R4),DEBMOD(R0) ;new DEBMOD ← old DEBMOD
.ENDC
EVWAIT INTEVT ;Interlock sensitive operation.
MOV #NXTINT+ISTBLK,R1 ;Link into the interpreter list.
MOV (R1),NXTINT(R0) ;
MOV R0,(R1) ;
EVSIG INTEVT ;End of interlock
MOV (SP)+,EVT(R0);new EVT ← second argument.
MOV R0,-(SP) ;Save LOC[new interpreter status block]
MOV #INSTSZ,R0 ;R0 ← Size needed for an interpreter stack
JSR PC,GTFREE ;R0 ← LOC[new interpreter stack]
MOV (SP)+,R1 ;R1 ← LOC[new interpreter status block]
MOV R0,STKBAS(R1) ;Store away new stack base
ADD #2*INSTSZ,R0 ;R0 ← LOC[top of new stack] (INSTSZ is in bytes)
MOV R1,-(SP) ;Save R1
MOV R0,-(SP) ;Save R0
MOV #210,R0 ;Room for process descriptor
JSR PC,GTFREE ;R0 ← LOC[new process descriptor]
MOV #UFPUSE+UGRSAV,PDBSTA(R0);Use floating point, use saved registers.
MOV #420,UPDLEN(R0) ;Length of PCB
; MOV (R2),PDBR2(R0) ;Transfer register 2 (not currently necessary)
MOV (SP)+,R1 ;R1 ← LOC[new interpreter stack top]
MOV R1,PDBR3(R0) ;Store away new interp stack pointer (reg 3)
MOV (SP)+,R1 ;R1 ← LOC[new ISB]
MOV R0,PCB(R1) ;Store away LOC[PCB] in new ISB
MOV R1,PDBR4(R0) ;Store away LOC[ISB] in reg 4 of PCB
; MOV R5,PDBR5(R0) ;Store away reg 5 (not currently necessary)
MOV SP,R1 ;
TST (R1)+ ;
MOV R1,PDBSP(R0) ;Store away the new stack pointer (reg 6)
MOV #INTERP,PDBPC(R0);Store away the new PC
RTS PC ;Done
; These are the appropriate scheduling commands:
; SCHEDU R0,#INTERP,#0,#2;Cause the new process to be started, suspended
; FORK R0,#INTERP,#0 ;Cause the new process to be started.
SPROUT: ;Interpreter routine
COMMENT ⊗ Arguments: One address in pseudo-code for each of the
several forks starting up, followed by a 0 word. This is to be used
only for cobegins, not for servos. Each new interpreter is given an
interpreter status block and is then scheduled. As each terminates,
it signals its defining event. Since each of these has the same
event, the current interpreter need only wait until they all happen.
⊗
MOV R3,-(SP) ;Save R3. Caution: cannot use interpreter stack now.
CLR R3 ;R3 is the count of how many inferiors to spawn.
EVMAK ;-(SP) ← Event identifier for communication with infs.
SPR2: MOV @IPC(R4),R0 ;R0 ← next argument (IPC)
BEQ SPR1 ;If zero, then we have spawned all the inferiors.
BMPIPC ;Bump IPC
INC R3 ;Count it.
MOV (SP),R1 ;R1 ← event for the inferior EVT
JSR PC,SPAWN ;R0 ← process control block of new interpreter
SCHEDU R0,#INTERP,#0,#2;Cause the new process to be started, suspended
BR SPR2 ;Go handle the next inferior.
SPR1: BMPIPC ;Bump IPC
SPR4: DEC R3 ;Another wait to be done?
BMI SPR3 ;No, we are finished.
EVWAIT (SP) ;Wait for an inferior to come back.
BCC SPR4 ;If all well, wait for the next one.
HALERR SPRMES ;The event was killed!
SPR3: EVKIL (SP)+ ;Kill the event now, remove from stack
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code.
RTS PC ;Done
SPRMES: ASCIE /BAD RETURN FROM INFERIOR/
TERMINATE:
COMMENT ⊗ Interpreter routine, sometimes jumped to from other
interpreter routines. End this interpreter. ⊗
MOV EVT(R4),R0 ;R0 ← event to announce imminent demise
BEQ TERM1 ;If there is one
EVSIG R0 ;Announce that we are about to disappear.
TERM1: MOV STKBAS(R4),R0 ;Reclaim interpreter stack
JSR PC,RLFREE ;
MOV PCB(R4),R0 ;Reclaim process control block (may be dangerous)
JSR PC,RLFREE ;
MOV R4,R0 ;Reclaim Interpreter Status Block
JSR PC,RLFREE ;
EVWAIT INTEVT ;Enter critical region.
MOV #ISTBLK,R0 ;The following unlinks this interpreter from the chain.
TERM3: MOV R0,R1 ;
MOV NXTINT(R1),R0;
CMP R0,R4 ;Have we found ours yet?
BNE TERM3 ;
MOV NXTINT(R4),NXTINT(R1); Yes. rechain.
EVSIG INTEVT ;Leave critical region.
DISMIS ;Go away
;Graph node handlers: MCLC, ENDCLC;
.IFNZ GRAPH1
COMMENT ∞ All this has equivalent code in GRAPH1.PAL
.ENDC
COMMENT ⊗ Make a calculator for a graph node. This involves several
data: the target variable, specified as a level-offset pair, the
location of the calculator code, (which is ordinary interpreter code
which leaves one value on the interpreter stack and then calls
ENDCLC, which puts that value in R0 and returns), and the list of
needed cells for the calculation. These data are passed as arguments
to MCLC: target (level-offset), IPC (absolute address), needed list
(list of level-offsets, terminated by 0). Recall that a calculator
cell looks like this:
II==0
XX NXTCLC ;next calculator cell in chain
XX NEEDED ;list of needed nodes. Each is a cell link whose datum
; is an absolute pointer and which is only forward linked.
XX CLCISB ;Points to interpreter status block to resolve addressing
XX CLCIPC ;the interpeter PC where the calculation starts
CLCCSZ == II/2;Size of calculator cell, in words
⊗
MCLC: ;Interpreter routine.
MOV R2,-(SP) ;Save R2
MOV R3,-(SP) ;Save R3
MOV #CLCCSZ,R0 ;Get room for a calculator cell
JSR PC,GTFREE ;
MOV R0,R3 ;R3 ← LOC[new calculator cell]
MOV R4,CLCISB(R3) ;store away ISB
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[target graph node]]
MOV (R0),R2 ;R2 ← LOC[target graph node]
MOV @IPC(R4),CLCIPC(R3) ;store away target IPC
BMPIPC ;Bump IPC
;form the needed list
CLR -(SP) ;Start with null needed list on the stack
MCLC2: MOV @IPC(R4),R0 ;R0 ← the next needed level-offset
BEQ MCLC1 ;Any more?
JSR PC,GETARG ;R0 ← LOC[LOC[next needed graph node]]
MOV (R0),-(SP) ;Stack next needed graph node
BMPIPC ;Bump IPC
.IFNZ SMALLB ;Get a new cell for needed list
MOV #CELSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #2,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV (SP)+,DATUM(R0);Needed graph node
MOV (SP),LINKF(R0);Link to rest of needed list
MOV R0,(SP) ;New needed list
BR MCLC2 ;
MCLC1: BMPIPC ;Bump IPC
MOV (SP)+,NEEDED(R3) ;store away needed list
CALL ADDCLC,<R2,R3> ;Do the final linking
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code
RTS PC ;Done
ENDCLC: ;Interpreter routine. Called as last instruction in a calculator
;cell. Returns via an RTS RF. Does not unlink anything.
MOV RF,SP ;Reset the stack
TST -(SP) ;
MOV (R3)+,R0 ;Get the coveted value cell
RTS RF ;Will return to the calling point in EVLCLC.
; MCHGR, GTOLD, GTNEW
COMMENT ⊗ Make a changer for a graph node. This involves several
data: the target variable, specified as a level-offset pair, and the
location of the changer code, (which is ordinary interpreter code
which terminates with TERMINATE). These data are passed as arguments
to MCHG: target (level-offset), IPC (absolute address). Recall that
a changer cell looks like this:
II==0
XX NXTCHG ;next changer cell in chain
XX CHGISB ;Points to interpreter status block to resolve addressing
XX CHGIPC ;the interpeter PC where the calculation starts
CHGCSZ == II/2 ;Size of changer cell, in words
⊗
MCHG: ;Interpreter routine.
MOV R2,-(SP) ;Save R2
MOV R3,-(SP) ;Save R3
MOV #CHGCSZ,R0 ;Get room for a changer cell
JSR PC,GTFREE ;
MOV R0,R3 ;R3 ← LOC[new changer cell]
MOV R4,CHGISB(R3) ;store away ISB
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[target graph node]]
MOV (R0),R2 ;R2 ← LOC[target graph node]
MOV @IPC(R4),CHGIPC(R3) ;store away target IPC
BMPIPC ;Bump IPC
CALL ADDCHG,<R2,R3> ;Do the final linking
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code
RTS PC ;Done
GTOLD: ;Interpreter routine
COMMENT ⊗ Gets the OLD value that this changer (acting as an
interpreter) has access to; puts it on the stack. ⊗
MOV OLDV(R4),-(R3)
CCC ;Clear condition code
RTS PC ;Done
GTNEW: ;Interpreter routine
COMMENT ⊗ Gets the NEW value that this changer (acting as an
interpreter) has access to; puts it on the stack. ⊗
MOV NEWV(R4),-(R3)
CCC ;Clear condition code
RTS PC ;Done
; ∞ End of commented-out portion for GRAPH1
;return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG, SSBRTN
COMMENT ⊗ All timings are averages of 1000 runs. They take into
account the cost of the RTS but not the JSR. It is assumed that
GETSCA and GETVEC take no time. All routines on this page are
interpreter routines. ⊗
;30 microseconds
SADD: ;Scalar ← Scalar + Scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
ADDF @(R3)+,AC0 ;AC0 ← arg2 + arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
SSUB: ;Scalar ← Scalar - Scalar
LDF @2(R3),AC0 ;AC0 ← arg 1
SUBF @(R3)+,AC0 ;AC0 ← arg1 - arg2
TST (R3)+ ;Move past first argument
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;30 microseconds
SMUL: ;Scalar ← scalar * scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
MULF @(R3)+,AC0 ;AC0 ← arg2 * arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;33 microseconds
SDIV: ;Scalar ← Scalar / Scalar
LDF @(R3)+,AC1 ;AC1 ← arg 2
LDF @(R3)+,AC0 ;AC0 ← arg 1
DIVF AC1,AC0 ;AC0 ← arg1 / arg2
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;26 microseconds
SNEG: ;Scalar ← -Scalar
LDF @(R3)+,AC0 ;AC0 ← arg
NEGF AC0 ;AC0 ← -arg
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;96 -- 116 microseconds
VDOT: ;Scalar ← Vector dot Vector
;S ← (X1X2 + Y1Y2 + Z1Z2) / W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #3,R2 ;R2 ← 3: Length of vector
VDV1: LDF (R0)+,AC1 ;Form sum of products of first 3 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,VDV1 ;Loop until all 3 fields done.
DIVF (R0),AC0 ;Divide by W1
DIVF (R1),AC0 ;Divide by W2. AC0 now has answer.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code.
RTS PC ;Done
;103 -- 116 microseconds
PVDOT: ;Scalar ← Plane dot Vector
;S ← X1X2 + Y1Y2 + Z1Z2 + W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #4,R2 ;R2 ← 4: Length of vector and weight
PDV1: LDF (R0)+,AC1 ;Form sum of products of all 4 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,PDV1 ;Loop until all 3 fields done.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code.
RTS PC ;Done
;199 -- 207 microseconds
VMAGN: ;Scalar ← Norm (vector)
;S ← SQRT(XX + YY+ ZZ) / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Push LOC[W] onto system stack, to save across SQRTF
JSR PC,@LSQRTF ;AC0 ← SQRT(XX + YY + ZZ)
DIVF @(SP)+,AC0 ;AC0 ← AC0 / W
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store answer
CCC ;Clear condition code.
RTS PC ;Done
SSBRTN: ;Call a routine.
MOV (R3)+,R1 ;R1 ← LOC[arg]
LDF (R1),AC0 ;AC0 ← arg
MOV @IPC(R4),R0 ;R0 ← which routine (a small number)
BMPIPC ;Bump IPC
ASL R0 ;Double (words → bytes)
BLE SSBRT1 ;Too small.
CMP R0,#SBLSIZ ;Too large?
BGE SSBRT1 ;Yes
JSR PC,@SBRLST(R0) ;Call a routine. AC0 ← answer.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store answer
CCC ;Clear condition code.
RTS PC ;Done
SSBRT1: HALERR SSBRMS ;Complain
SCC ;Set condition code
RTS PC ;Done
SSBRMS: ASCIE </NO SUCH SUBROUTINE/>
SBRLST: ;List of legal subroutines
0 ;Illegal
SQRT ;The only one right now. #1
SBLSIZ == .-SBRLST ;The size of the list (bytes)
SQRT: JMP @LSQRTF ;Let it do the returning
;Vector utilities: UNITV, CROSV
COMMENT ⊗ These are not currently being used
;281 -- 286 microseconds
UNITV: ;Vector ← V / Norm(V)
;S ← SQRT(XX + YY+ ZZ) / W
MOV (R3),R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Save R1 across SQRTF
JSR PC,SQRTF ;AC0 ← SQRT(XX + YY + ZZ)
MOV (SP)+,R1 ;Restore R1
DIVF (R1),AC0 ;AC0 ← Norm = SQRT / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R2 ;R2 ← count of fields
UNITV1: LDF (R1)+,AC1 ;AC1 ← field of vector
DIVF AC0,AC1 ;divide by norm
STF AC1,(R0)+ ;Store result
SOB R2,UNITV1 ;Loop until done
MOV (R1)+,(R0)+ ;Copy W.
MOV (R1),(R0) ; (two words long)
CCC ;Clear condition code
RTS PC ;Done
;172 -- 184 microseconds
CROSV: ;Vector ← Vector cross Vector
;X ← Y1Z2 - Y2Z1
;Y ← X2Z1 - X1Z2
;Z ← X1Y2 - X2Y1
;W ← W1W2
;AC0, 1, 2, 3, 4, 5 are garbaged by this routine.
MOV (R3),R2 ;R2 ← LOC[arg 2]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV 4(R3),R1 ;R1 ← LOC[arg 1]. Must not pop R3 stack yet!
LDF 14(R1),AC0 ;AC0 ← W1
MULF 14(R2),AC0 ;AC0 ← W1W2
STF AC0,14(R0) ;Store AC0 → W
LDF 4(R1),AC0 ;AC0 ← Y1
LDF (R2),AC1 ;AC1 ← X2
LDF 4(R2),AC2 ;AC2 ← Y2
LDF (R1),AC3 ;AC3 ← X1
STF AC3,AC4 ;AC4 ← X1
STF AC0,AC5 ;AC5 ← Y1
MULF AC2,AC3 ;AC3 ← X1Y2
MULF AC1,AC0 ;AC0 ← X2Y1
SUBF AC0,AC3 ;AC3 ← X1Y2 - X2Y1
STF AC3,10(R0) ;Z ← AC3
LDF 10(R2),AC0 ;AC0 ← Z2
LDF 10(R1),AC3 ;AC3 ← Z1
MULF AC4,AC0 ;AC0 ← X1Z2
MULF AC3,AC1 ;AC1 ← X2Z1
SUBF AC0,AC1 ;AC1 ← X2Z1 - X1Z2
STF AC1,4(R0) ;Y ← AC1
LDF 10(R2),AC0 ;AC0 ← Z2
MULF AC5,AC0 ;AC0 ← Y1Z2
MULF AC2,AC3 ;AC3 ← Y2Z1
SUBF AC3,AC0 ;AC0 ← Y1Z2 - Y2Z1
STF AC0,(R0) ;X ← AC0
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
CCC ;Clear condition code
RTS PC ;Done
⊗ END OF COMMENTED-OUT PROCEDURES.
;Return vectors: SVMUL, TVMUL, VMAKE, VADD
;83 -- 91 microseconds
SVMUL: ;Vector ← Scalar * Vector. Interpreter routine
;X ← S*X, Y ← S*Y, Z ← S*Z, W ← W
MOV (R3)+,R2 ;R2 ← LOC[vector]
LDF @(R3)+,AC0 ;AC0 ← scalar;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R1 ;R1 ← 3: How many fields to handle
SVM1: LDF (R2)+,AC1 ;AC1 ← next field of vector
MULF AC0,AC1 ;AC1 ← product
STF AC1,(R0)+ ;Store result
SOB R1,SVM1 ;Loop until all 3 fields done.
MOV (R2)+,(R0)+ ;Transfer W
MOV (R2)+,(R0)+ ; which is 2 words long.
CCC ;Clear condition code
RTS PC ;Done
VMAKE: ;Interpreter routine
LDF @(R3)+,AC1 ;Fetch X
LDF @(R3)+,AC2 ;Fetch Y
LDF @(R3)+,AC3 ;Fetch Z
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Store W
CLR (R0) ;Store W (second word)
CCC ;Clear condition code
RTS PC ;Done
VADD: ;Interpreter routine
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
LDF (R0)+,AC1 ;Calculate X
ADDF (R1)+,AC1 ;
LDF (R0)+,AC2 ;Calculate Y
ADDF (R1)+,AC2 ;
LDF (R0)+,AC3 ;Calculate Z
ADDF (R1)+,AC3 ;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Assume W is 1
CLR (R0) ;
CCC ;Clear condition code
RTS PC ;Done
;283 -- 324 microseconds
TVMUL: ;Vector ← Trans * Vector. Interpreter routine
MOV (R3),R2 ;R2 ← LOC[vector]
MOV 2(R3),R0 ;R0 ← LOC[trans]
CLRF AC1 ;X ← 0
CLRF AC2 ;Y ← 0
CLRF AC3 ;Z ← 0
MOV #4,R1 ;R1 ← How many columns left to go
TVM1: LDF (R2)+,AC0 ;AC0 ← field of vector
STF AC0,AC5 ;AC5 ← copy of AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC1 ;Add partial result to X
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC2 ;Add partial result to Y
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC3 ;Add partial result to Z.
ADD #4,R0 ;Skip bottom row
SOB R1,TVM1 ;Go back to do all 4 columns.
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV -4(R2),(R0)+;Copy W from the vector
MOV -2(R2),(R0) ; (2 words long)
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
CCC ;Clear condition code
RTS PC ;Done
;Return a trans: TMAKE, TVADD, TTMUL
TMAKE: ;Interpreter routine.
;All that is required is to take the rot part of the first argument,
;and the vector from the second part;
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
MOV (R3)+,-(SP) ;Push LOC[arg 2]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV #14,R2 ;R2 ← Count of how many copies to make
TMK1: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK1 ;Repeat until done
MOV (SP)+,R1 ;R1 ← LOC[arg 2]
MOV #4,R2 ;R2 ← Count of how many copies to make
TMK2: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK2 ;Repeat until done
CCC ;Clear condition code.
RTS PC ;Done.
TVADD: ;Interpreter routine.
;All that is required is to take the rot part of the first argument,
;and add the vector from the first part to the second argument.
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
MOV (R3)+,R2 ;R2 ← LOC[arg 2]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV R3,-(SP) ;Save R3
MOV #14,R3 ;R3 ← Count of how many copies to make
TVA1: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R3,TVA1 ;Repeat until done
MOV #3,R3 ;R3 ← Count of how many additions to perform
TVA2: LDF (R1)+,AC0 ;AC0 ← word from trans
ADDF (R2),AC0 ; + word from vector
STF AC0,(R0)+ ;
SOB R3,TVA2 ;Repeat until done
MOV ONE,(R0)+ ;Set last word to 1.0
CLR (R0) ;
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code.
RTS PC ;Done.
TTMUL: ;Interpreter routine
;Multiplies two transes together. Takes advantage of the fact that
;last row is 0 0 0 1.
MOV (R3)+,R2 ;R2 ← LOC[arg 2]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV R3,-(SP) ;Save R3
MOV R4,-(SP) ;Save R4
MOV #4,R4 ;Loop count for cols of answer
MOV R1,-(SP) ;Save a copy of R1
TTM2: LDF (R2)+,AC1 ;Pick up a column of arg2: First row
LDF (R2)+,AC2 ; Second row
LDF (R2)+,AC3 ; Third row
STF AC3,AC4 ; store in AC4
ADD #4,R2 ; Fourth row is zero
MOV #3,R3 ;Loop count for rows of answer
TTM1: LDF (R1),AC3 ;First col of arg 1
MULF AC1,AC3 ;
LDF 20(R1),AC0 ;Second col of arg 1
MULF AC2,AC0 ;
ADDF AC0,AC3 ;
LDF 40(R1),AC0 ;Third col of arg 1
MULF AC4,AC0 ;
ADDF AC0,AC3 ;
STF AC3,(R0)+ ;
ADD #4,R1 ;Move to next column of arg 1
SOB R3,TTM1 ;Repeat for first 3 rows of answer
CLR (R0)+ ;Last row of answer is zero
CLR (R0)+ ;
MOV (SP),R1 ;Reset R1 to point to first row of arg 1
SOB R4,TTM2 ;Repeat for all four columns of answer
LDF -20(R0),AC1 ;Add correction for last column, first row
ADDF 60(R1),AC1 ;
STF AC1,-20(R0) ;
LDF -14(R0),AC1 ;Add correction for last column, second row
ADDF 64(R1),AC1 ;
STF AC1,-14(R0) ;
LDF -10(R0),AC1 ;Add correction for last column, third row
ADDF 70(R1),AC1 ;
STF AC1,-10(R0) ;
MOV ONE,-4(R0) ;Make last col, last row get a one.
TST (SP)+ ;Pop the R1 temp
MOV (SP)+,R4 ;Restore R4
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code
RTS PC ;Done
;Motion: MOVE
MOVE: ;Interpreter routine
.IFNZ MOVING ;If this version is supposed to be able to move
MOV #'π,R0 ;Whistle while you work
JSR PC,TYPCHR ;
MOV #34,R0 ;Get a device block
JSR PC,GTFREE ;
MOV R0,R1 ;R1 ← address of device block
MOV R0,-(SP) ;Save a copy on the stack
MOV @IPC(R4),R0 ;R0 ← address of coefficient list
BMPIPC ;Bump IPC
JSR PC,@LMOVE ;Put a move on
TST R0 ;All well?
BEQ MOV1 ;Yes
HALERR MOVERR ;No, better complain.
MOV1: MOV (SP)+,R0 ;
JSR PC,RLFREE ;Get rid of the device block
CCC ;Clear condition code
RTS PC ;Return
MOVERR: ASCIE </SERVO ERROR. ERROR BITS IN R0. DEVICE BLOCK AT (R1)/>
.IFF ;If not a moving version
HALERR MOVERR ;Can't move
BMPIPC ;Bump IPC
CLR R0 ;
RTS PC ;Return
MOVERR: ASCIE </SORRY, THIS VERSION CAN'T EVEN LIFT A FINGER/>
.ENDC
;Condition monitors: CMMAK
.IFNZ ONMONS
COMMENT ⊗ This is the second version of condition monitors (here
refered to as c-m's). Hardware-type c-m's are still not ready. The
checker and the body are the same job in this version; before 10/2/75
they were seperate. The basic operations are Creation, Enabling,
Disabling, Destruction. Creation causes a c-m control block to be
set up, and pointed to by the c-m variable. This block has the
following fields: ⊗
II == 0
XX CMSEVT ;The event used to awaken the tester upon enabling
XX CMTEVT ;The event for which this c-m tests, if any
XX CMFORC ;The FMCB needed, if any, for calculating forces
XX CMSTAT ;Status bits for the c-m
CMENB == 1 ;set => enabled
CMDES == 2 ;set => to be destroyed
CMCBSZ == II/2 ;Length in words of a c-m control block.
COMMENT ⊗ The once-only code of the c-m is sprouted at priority 3 (it
is an interpreter), and after initialization, it waits for the
gronking event CMSEVT. Enabling signals the event CMSEVT and sets
the enabled bit in CMSTAT. Disabling resets the enabled bit, and the
c-m will wait on the CMSEVT for future action. As long as the c-m is
enabled, it periodically wakes up, checks its status bits. If the
enable bit is reset, the c-m waits for CMSEVT. Else it checks the
condition. If it is satisfied, the c-m disables itself and
proceeds to the conclusion and level 1. (The conclusion should reset
itself to level 0 after all critical activity has been accomplished.)
Otherwise, it reschedules itself. If the destroy bit should ever be
set in CMSTAT, then the c-m will destroy the event CMSEVT. Then
it will reclaim the c-m control block and will dismiss, never to
return. (The pointer to the c-m in the environment should be zeroed
by the destroying angel.). ⊗
CMMAK: ;Interpreter routine
COMMENT ⊗ Takes three arguments, the offset of the nascent c-m, the
level-offset of the event that this monitor is to wait on, if any,
and the IPC of the c-m code. ⊗
MOV @IPC(R4),R2 ;R2 ← offset
BMPIPC ;Bump IPC
ADD ENV(R4),R2 ;R2 ← Pointer into environment
TST (R2) ;Already something there?
BEQ CMMK1 ;
HALERR CMMMSG ;Yes. complain.
;Make a c-m control block
CMMK1: MOV #CMCBSZ,R0 ;
JSR PC,GTFREE ;R0 ← LOC[c-m control block]
MOV R0,(R2) ;Stuff into environment
EVMAK ;
MOV (SP)+,CMSEVT(R0) ;Make an event for CMSEVT
CLR CMSTAT(R0) ;Disabled, undestroyed
CLR CMTEVT(R0) ;Not necessarily ON <event> DO
MOV R0,-(SP) ;Save LOC[c-m control block]
MOV @IPC(R4),R0 ;R0 ← level-offset of event this c-m waits for.
BMPIPC ;Bump IPC
TST R0 ;If any
BEQ CMMK2 ;
JSR PC,GETARG ;R0 ← LOC[environment location of event]
MOV (SP),R1 ;R1 ← LOC[c-m control block]
MOV (R0),CMTEVT(R1) ;Put the CMTEVT in the c-m control block.
;Prepare the c-m job
CMMK2: MOV @IPC(R4),R0 ;R0 ← IPC of c-m code
BMPIPC ;Bump IPC
CLR R1 ;C-m's do not expire with events
JSR PC,SPAWN ;R0 ← process control block for c-m
MOV PDBR4-PDBSTA(R0),R2;R2 ← PR4 = LOC[c-m's interpeter status block]
MOV (SP)+,CMCB(R2);Stuff CMCB of the c-m
FORK R0,#INTERP,#3;Cause the c-m to be started. It will go into wait.
CCC ;Clear condition code
RTS PC ;Done
CMMMSG: ASCIE </CMMAK: WILL CREATE EXISTENT CONDITION MONITOR/>
; CMENBL, CMDSBL, CMDEST, CMTRIG, CMSKED, CMUNCR
CMNEMS: ASCIE </TRYING TO TREAT NON-EXISTENT EVENT/>
CMENBL: ;Interpeter routine
; One argument, a level-offset pair for the c-m to enable.
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← pointer into environment
MOV (R0),R0 ;R0 ← pointer to c-m control block.
BEQ CMDERR ;If none, then error
BIS #CMENB,CMSTAT(R0) ;Set the enable bit
EVSIG CMSEVT(R0) ;Gronk the c-m
CCC ;Clear condition code
RTS PC ;Done
CMEERR: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMDSBL: ;Interpreter routine
; One argument, a level-offset pair for the c-m to disable.
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← pointer into environment
MOV (R0),R0 ;R0 ← pointer to c-m control block.
BEQ CMDERR ;If none, then error
BIC #CMENB,CMSTAT(R0) ;Clear the enable bit
CCC ;Clear condition code
RTS PC ;Done
CMDERR: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMDEST: ;Interpreter routine
COMMENT ⊗ Argument list. Each is an offset for the c-m to destroy.
The list is terminated with a zero entry. ⊗
MOV @IPC(R4),R0 ;R0 ← offset
BEQ CMDS1 ;If 0, then done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
MOV (R0),R1 ;R1 ← LOC[c-m control block]
BEQ CMDSER ;If none, then error
BIS #CMDES,CMSTAT(R1) ;Set the destroy bit
EVKIL CMSEVT(R1);Destroy the event. That ought to wake him up!
CLR (R0) ;Remove c-m from environment
BR CMDEST ;Go do the next one.
CMDS1: BMPIPC ;Bump IPC the last time
CCC ;Clear condition code
RTS PC ;Done
CMDSER: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMTRIG: ;Interpeter routine
COMMENT ⊗ Should be executed only from a c-m. Sets the priority to 1
and disables the checker. ⊗
MOV CMCB(R4),R0 ;
CMTR1: EVTST CMSEVT(R0);Eat all signals enabling the checker.
BCC CMTR1 ;
BIC #CMENB,CMSTAT(R0) ;Clear the enable bit
MOV PCB(R4),R0 ;
CLR 2(R0) ;Clear word 1 of process control block to reset nominal
; priority to 0.
SETPRI #1 ;Set the priority to 1
TST (SP)+ ;Discard old priority
CCC ;Clear condition code
RTS PC ;Done
CMSKED: ;Interpreter routine
COMMENT ⊗ Goes to sleep a while (currently, 100 milliseconds). Upon
awakening, checks the status bits of this checker, and either
dismisses, waits, or returns. ⊗
SETPRI #3 ;In case the conclusion left it at 1 or 0.
TST (SP)+ ;Flush old priority
MOV @IPC(R4),-(SP) ;Waiting interval
BMPIPC ;Bump IPC
SLEEP ;Sleep a while
MOV CMCB(R4),R0 ;R0 ← c-m control block
CMSK4: BIT #CMDES,CMSTAT(R0) ;Destroy bit set?
BEQ CMSK1 ;No
EVKIL CMSEVT(R0);Yes. Kill the triggering event.
CMSK3: JSR PC,RLFREE ;Return the c-m control block
JMP TERMINATE ;Use the interpeter terminate routine.
CMSK1: BIT #CMENB,CMSTAT(R0) ;Enable bit set?
BNE CMSK2 ;Yes.
EVWAIT CMSEVT(R0);No. Wait until signaled by the enabler
BCS CMSK3 ;If the enabling event died, so must we.
BR CMSK4 ;Else start from the awakening point.
CMSK2: MOV CMTEVT(R0),R1 ;R1 ← event to test for
BEQ CMSK5 ;If any
EVWAIT R1 ;Wait for event to happen
BIT #CMENB,CMSTAT(R0) ;Still enabled?
BNE CMSK5 ;Yes. May exit.
EVSIG R1 ;Oops, we were disabled! Resignal the event.
BR CMSK4 ;And try again.
CMSK5: CCC ;Clear condition code
RTS PC ;Done
CMUNCR: ;Interpreter routine.
COMMENT ⊗ Used in body of c-m. Starts uncritical section. ⊗
MOV PCB(R4),R0 ;
CLR 2(R0) ;Clear word 1 of process control block to reset nominal
; priority to 0.
SETPRI #0 ;Set the priority to 0
TST (SP)+ ;Flush old priority
CCC ;Clear condition code
RTS PC ;Done
.ENDC ; End of the ONMON material
;Force condition monitors. Data structures. TABOFS, FMBLK, MAKFORCE, DESFORCE
COMMENT ⊗ Certain tables are available via COMTAB entries. LERRPTR
points to the table ERRPTR of 16 words, one for each servo, which
points at the current error torques. LTHPTR points at the table THPTR
of 16 words, one for each servo, which points at the current joint
angles. ⊗
; Mechanism bits.
YARM == 1
YHAND == 2
BARM == 4
BHAND == 10
ANARM == YARM + BARM
AHAND == YHAND + BHAND
; Table offsets for various mechanisms.
OFYARM == 0
OFYHAND == 6*2
OFBARM == 7*2
OFBHAND == 15*2
TABOFS:
COMMENT ⊗ R0 = Mechanism bit. Returns table offset (in bytes) in R0.
For example, if the mechanism is BARM, the OFBARM is returned. ⊗
BIT #YARM,R0 ;Is it this mechanism?
BEQ TABOF1 ;No
MOV #OFYARM,R0 ;Yes. Load up proper offset
RTS PC ; and return.
TABOF1: BIT #YHAND,R0 ;Is it this mechanism?
BEQ TABOF2 ;No
MOV #OFYHAND,R0 ;Yes. Load up proper offset
RTS PC ; and return.
TABOF2: BIT #BARM,R0 ;Is it this mechanism?
BEQ TABOF3 ;No
MOV #OFBARM,R0 ;Yes. Load up proper offset
RTS PC ; and return.
TABOF3: BIT #BHAND,R0 ;Is it this mechanism?
BEQ TABOF4 ;No
MOV #OFBHAND,R0 ;Yes. Load up proper offset
RTS PC ; and return.
TABOF4: HALERR TABMES ;Illegal
CLR R0 ;
RTS PC ;
TABMES: ASCIE </ILLEGAL MECHANISM/>
; Force monitor block (FMBLK)
II == 0
FMFOMO == II ;Force - moment array. 20 words.
;WORD 0,0 force component in X direction
;WORD 0,0 ditto for Y
;WORD 0,0 Z
;WORD 40200,0 (1.0) scaling factor, not used
;WORD 0,0 moment component in X direction
;WORD 0,0 Y
;WORD 0,0 Z
;WORD 40200,0 1.0
II == II + 40
FMRETO == II ;Reaction - torque array. 14 words.
II == II + 30
FMJOAN == II ;Joint angle array. 14 words.
II == II + 30
FMMECH == II ;Arm involved: mechanism bits
II == II + 2
FMSCAL == II ;Scale factor. (sum of squares of RETO)
II == II + 4
FMMODE == II ;Mode bits
FMKIL == 2 ;set if this FM should go away.
FMBEX == 4 ;set if background job
; (fills reaction-torque array) exists
FMFEX == 10 ;set by GETFORCE, reset by MAKRT
II == II + 2
FMSIZ == II/2 ;Length in words of force monitor block
MAKFORCE: ;Interpreter routine
COMMENT ⊗ Prepares the force variable needed to compute forces. The
offset is the first argument, and the mechanism number is the second
argument. Sets the environment pointing to a new force monitor
block, whose force-moment array it fills from the two top elements of
the stack, which are then popped: the first is the force vector, the
second is the moment vector. These are both in hand coordinates. This
routine does not load the reaction-torque array or the joint angle
array. ⊗
MOV #FMSIZ,R0 ;
JSR PC,GTFREE ;R0 ← LOC[new fmblock]
CLR FMMODE(R0) ;Reset all mode bits
MOV @IPC(R4),R1 ;R1 ← offset
BMPIPC ;Bump IPC
ADD ENV(R4),R1 ;R1 ← LOC[place in environment]
MOV R0,(R1) ;Stow away the pointer to the new fmblock
MOV @IPC(R4),FMMECH(R0) ;Stow away the mechanism in the new fmblock
BMPIPC ;Bump IPC
MOV (R3)+,R1 ;R1 ← LOC[moment vector]
MOV (R3)+,R2 ;R2 ← LOC[force vector]
ADD #FMFOMO,R0 ;R0 ← LOC[force-moment vector]
MOV R3,-(SP) ;Save R3
MOV #6,R3 ;R3 ← count: how many words to transfer
MAKFC1: MOV (R2)+,(R0)+ ;transfer force vector
SOB R3,MAKFC1 ;repeat
MOV ONE,(R0)+ ;
CLR (R0)+ ;
MOV #6,R3 ;R3 ← count: how many words to transfer
MAKFC2: MOV (R1)+,(R0)+ ;transfer moment vector
SOB R3,MAKFC2 ;repeat
MOV ONE,(R0)+ ;
CLR (R0) ;
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code
RTS PC ;Return
DESFORCE: ;Interpreter routine
COMMENT ⊗ One argument: the level-offset of the force block to
destroy. Reclaims the space. If anyone was using it, tough.
Currently nothing is done to inform anyone that it is going away. ⊗
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[environment point]
MOV R0,R2 ;For safekeeping
MOV (R0),R0 ;R0 ← LOC[fm control block]
BEQ DESF1 ;If any
CLR (R2) ;Remove mention in the environment
BIS #FMKIL,FMMODE(R0) ;Set the destroy bit.
CCC ;Clear condition code
RTS PC ;Done
DESF1: HALERR DESMSG ;Complain
SCC ;Set condition code
RTS PC ;Done
DESMSG: ASCIE </CANT DESTROY NON-EXISTENT FORCE MONITOR/>
; GETFORCE, MAKRT
GETFORCE: ;Interpreter routine
COMMENT ⊗ One argument, the level-offset of the force variable, which
points to the force monitor block. It is assumed that the reaction
torque array is already prepared. Calculates the current force on
the arm and places it on the stack. ⊗
MOV @IPC(R4),R0 ;R0 ← Level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[fmblock]]
MOV (R0),R2 ;R2 ← LOC[fmblock]
BEQ GTFRC4 ;If any
CLRF AC0 ;AC0 is the result force. Set to 0.
BIS #FMFEX,FMMODE(R2) ;Imply that we are still awake.
BIT #FMBEX,FMMODE(R2) ;Is there a MAKRT job?
BNE GTFRC6 ;Yes.
;Make a job for the MAKRT routine. Put LOC[fmblock] in its R0.
BIS #FMBEX,FMMODE(R2) ;Say that the MAKRT job exists.
MOV #210,R0 ;Room for process descriptor
JSR PC,GTFREE ;R0 ← LOC[new process descriptor]
MOV R2,PDBR0(R0) ;Put LOC[fmblock] in its new R0
MOV R0,PDBR1(R0) ;Put LOC[PCB] in its new R1
MOV #UFPUSE+UGRSAV,PDBSTA(R0);Use floating point, use saved registers.
MOV #420,UPDLEN(R0) ;Length of PCB
;do something about the stack pointer
MOV #MAKRT,PDBPC(R0) ;Store away the new PC
FORK R0,#MAKRT,#3 ;Cause the new process to be started.
GTFRC6: MOV FMMECH(R2),R0 ;R0 ← mechanism
JSR PC,TABOFS ;R0 ← offset into joint error table
ADD LERRPTR,R0 ;R0 ← LOC[proper place in error torque]
MOV R2,R1 ;
ADD #FMRETO,R1 ;R1 ← LOC[reaction torque array]
BIT #AHAND,FMMECH(R2) ;Is it a hand?
BEQ GTFRC1 ;No
MOV #1,R2 ;Yes, R2 ← 2 ← count of joints
BR GTFRC2 ;
GTFRC1: MOV #6,R2 ;R2 ← 6 ← count of joints
GTFRC2: LDF (R1)+,AC1 ;AC1 ← reaction torque
MULF @(R0)+,AC1 ; * joint error
ADDF AC1,AC0 ;cumulate
SOB R2,GTFRC2 ;repeat
DIVF FMSCAL(R2),AC0 ;Normalise
GTFRC3: JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store answer
CCC ;Clear condition code
RTS PC ;Return
GTFRC4: HALERR GTFMES ;Complain
SCC ;Set condition code
RTS PC ;Return
GTFMES: ASCIE </NO FORCE BLOCK/>
MAKRT:
COMMENT ⊗ This is a separate job which periodically reestablishes the
reaction torque array and the scale factor for a fmblock. When first
called, the location of the fmblock is in R0, and the location of the
PCB for the process is in R1. Makes sure that the force is still
needed (that is, that the FMKIL bit is off and the FMFEX is on) and
then sets up the array. Sleeps for half a second and tries it again.
If the FMKIL is on, then the fmblock and PCB are returned to free
storage and the process terminates. If FMFEX is off, then FMBEX is
turned off as well, the PCB is returned to free storage, and the
process terminates. ⊗
MOV R1,-(SP) ;Save the PCB address
MOV R0,R4 ;R4 ← LOC[fmblock]
MAKRT5: BIT #FMKIL,FMMODE(R4) ;Kill bit set?
BNE MAKRT3 ;Yes.
BIT #FMFEX,FMMODE(R4) ;Has GETFORCE been called recently?
BNE MAKRT4 ;Yes.
BIC #FMBEX,FMMODE(R4) ;No; say we are leaving.
BR MAKRT6 ;Leave
MAKRT4: BIC #FMFEX,FMMODE(R4) ;Reset the recency bit.
MOV FMMECH(R4),R0 ;R0 ← mechanism
JSR PC,TABOFS ;R0 ← offset into joint error table
ADD LTHPTR,R0 ;R0 ← LOC[proper place in joint ang table]
MOV R4,R1 ;
ADD #FMJOAN,R1 ;R1 ← LOC[joint angle list in fmblock]
BIT #AHAND,FMMECH(R4) ;Is it a hand?
BEQ MAKRT1 ;No
MOV #1,R3 ;Yes, R3 ← 1 ← words to transfer
BR MAKRT2 ;
MAKRT1: MOV #6,R3 ;R3 ← 6 ← words to transfer
MAKRT2: LDF @(R0)+,AC0 ;Transfer current joint angle
STF AC0,(R1)+ ;
SOB R3,MAKRT2 ;repeat
MOV R4,R0 ;
ADD #FMFOMO,R0 ;R0 ← LOC[force-moment array]
MOV R4,R1 ;
ADD #FMRETO,R1 ;R1 ← LOC[reaction torque array to be returned]
MOV FMMECH(R4),R3 ;R3 ← mechanism number
MOV R4,R2 ;
ADD #FMJOAN,R2 ;R2 ← LOC[current joint angles]
JSR PC,@LFORCE ;This actually fills the reaction torque array
MOV R4,R0 ;
ADD #FMRETO,R0 ;R0 ← LOC[reaction-torque array]
CLRF AC0 ;AC0 ← sum of the squares
BIT #AHAND,FMMECH(R4) ;Is it a hand?
BEQ MAKRT7 ;No
MOV #1,R3 ;Yes, R3 ← 1 ← words to sum
BR MAKRT8 ;
MAKRT7: MOV #6,R3 ;R3 ← 6 ← words to sum
MAKRT8: LDF (R0),AC1 ;compute sum of squares
MULF (R0)+,AC1 ;
ADDF AC1,AC0 ;
SOB R3,MAKRT8 ;
STF AC0,FMSCAL(R4) ;Store the sum of the squares
SLEEP #1000 ;Sleep half a second
BR MAKRT5 ;Do it again
MAKRT3: MOV R4,R0 ;R0 ← LOC[fmblock]
JSR PC,RLFREE ;Release the fmblock
MAKRT6: MOV (SP)+,R0 ;R0 ← LOC[PCB]
JSR PC,RLFREE ;Release the PCB
DISMIS ;Go away.
;Events: MAKEVT, SIGNAL, WAITE, DESEVT;
COMMENT ⊗ Events can be created (at the beginnings of blocks is the
usual place), signaled, awaited (in the middle of a block) and
destroyed (at the end of a block). Each event is a variable, that
is, it is refered to by a level-offset pair. However, its place in
the environment does not point to a graph node, since there is no
such thing as attachment to an event. The event itself is stored in
the environment. The garbage collector marking phase had better
understand this. ⊗
MAKEVT: ;Interpreter routine
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, a fresh event is
created and placed in the environment at the desired offset, current
level. ⊗
MOV @IPC(R4),R0 ;R0 ← offset
BEQ MAKEV1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
EVMAK ;Make an event.
MOV (SP)+,(R0) ;Stuff it away.
BR MAKEVT ;Repeat
MAKEV1: TST (SP)+ ;Clean off stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
SIGNAL: ;Interpreter routine. Signal the event of the level-offset pair.
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← equivalent pointer into environment
EVSIG (R0) ;Signal that event.
CCC ;Clear condition code.
RTS PC ;Done
WAITE: ;Interpreter routine. Wait on the event of the level-offset pair.
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← equivalent pointer into environment
EVWAIT (R0) ;Wait on that event.
BCS WAITE1 ;Return OK?
JMP TERMINATE ;The event was destroyed. I guess we should depart cleanly.
WAITE1:
CCC ;Clear condition code.
RTS PC ;Done
DESEVT: ;Interpreter routine
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, the event is
destroyed. ⊗
MOV @IPC(R4),R0 ;push offset
BEQ DESEV1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
EVKIL (R0) ;Kill the event
CLR (R0) ;Remove the event from the environment
BR DESEVT ;Repeat
DESEV1: BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
;Debugging aids: PRINT, PRNTS
PRINT: ;Interpreter routine
MOV @IPC(R4),R0 ;R0 ← Address of string
BMPIPC ;Bump IPC
JSR PC,TYPSTR ;Type it out
CCC ;Clear condition code
RTS PC ;Done
PRNTS: ;Interpreter routine. Prints the scalar on the stack, pops
MOV #CRLFX,R0 ;
JSR PC,TYPSTR ;
MOV (R3)+,R2 ;R2 ← LOC[scalar value]
.IFNZ FLOAT
LDF R2,AC0 ;
MOV #OUTBUF,R0 ;
JSR PC,CVG ;Convert number to floating string in outbuf
MOV #OUTBUF,R0 ;
JSR PC,TYPSTR ;
.IFF
MOV (R2)+,R0 ;R0 ← first part
JSR PC,TYPOCT ;Type it
MOV #40,R0 ;
JSR PC,TYPCHR ; " "
MOV (R2),R0 ;
JSR PC,TYPOCT ;Type second part
.ENDC
CCC ;Clear condition code
RTS PC ;Done
; BREAK, NOOP, TOPAL, IOINIT
.IFZ ALAID
BREAK: ;Interpreter routine
MOV #BRKMES,R0 ;
JSR PC,TYPSTR ;
BPT ;Cause a DDT break
CCC ;Clear condition code
RTS PC ;Done
BRKMES: ASCIE </
PROGRAM BREAK/>
.ENDC
NOOP: ;Interpreter routine
CCC ;Clear condition code
RTS PC ;Done
TOPAL: ;Interpreter routine
COMMENT ⊗ Escape to PAL. JSRs to the pseudo code. That code
should return via:
MOV PC,R0
RTS PC
⊗
JSR PC,@IPC(R4) ;Fly
ADD #2,R0 ;R0 ← Proper new IPC
MOV R0,IPC(R4) ;Hope R4, R3 still OK!
RTS PC ;Done.
CSLEVT: 0 ;Console interlock event
IOINIT:
; Initialize the debugger. Leave all breakpoints as they are.
EVMAK ;
MOV (SP),CSLEVT ;
EVSIG ;Make a console interlock event
RTS PC ;
;BUGS
COMMENT ⊗
⊗